Requires SDL
Requires SEKI
Requires FixedPoint
Requires Vectors

Only Forth Definitions

SDLK_A Constant <a>       SDLK_B Constant <b>       SDLK_C Constant <c>       SDLK_D Constant <d>
-? SDLK_E Constant <e>       SDLK_F Constant <f>       SDLK_G Constant <g>       SDLK_H Constant <h>
SDLK_I Constant <i>       SDLK_J Constant <j>      SDLK_K Constant <k>      SDLK_L Constant <l>
SDLK_M Constant <m>      SDLK_N Constant <n>      SDLK_O Constant <o>      SDLK_P Constant <p>
SDLK_Q Constant <q>      SDLK_R Constant <r>      SDLK_S Constant <s>      SDLK_T Constant <t>
SDLK_U Constant <u>      SDLK_V Constant <v>      SDLK_W Constant <w>      SDLK_X Constant <x>
SDLK_Y Constant <y>      SDLK_Z Constant <z>      SDLK_0 Constant <0>      SDLK_1 Constant <1>
SDLK_2 Constant <2>      SDLK_3 Constant <3>      SDLK_4 Constant <4>      SDLK_5 Constant <5>
SDLK_6 Constant <6>      SDLK_7 Constant <7>      SDLK_8 Constant <8>      SDLK_9 Constant <9>
SDLK_F1 Constant <f1>     SDLK_F2 Constant <f2>
SDLK_F3 Constant <f3>     SDLK_F4 Constant <f4>     SDLK_F5 Constant <f5>
SDLK_F6 Constant <f6>     SDLK_F7 Constant <f7>     SDLK_F8 Constant <f8>
SDLK_F9 Constant <f9>     SDLK_F10 Constant <f10>    SDLK_F11 Constant <f11>
SDLK_F12 Constant <f12>    SDLK_ESCAPE Constant <esc>    SDLK_BACKQUOTE Constant <`>
SDLK_MINUS Constant <->      SDLK_EQUALS Constant <=>      SDLK_BACKSPACE Constant <bksp>
SDLK_TAB Constant <tab>    SDLK_LEFTBRACKET Constant <[>      SDLK_RIGHTBRACKET Constant <]>
SDLK_RETURN Constant <enter>  SDLK_SEMICOLON Constant <;>      SDLK_QUOTE Constant <'>
SDLK_BACKSLASH Constant <\>      SDLK_COMMA Constant <,>      SDLK_PAUSE Constant <pause>
SDLK_SLASH Constant </>      SDLK_SPACE Constant <space>  SDLK_INSERT Constant <ins>
SDLK_DELETE Constant <del>    SDLK_HOME Constant <home>   SDLK_END Constant <end>
SDLK_PAGEUP Constant <pgup>   SDLK_PAGEDOWN Constant <pgdn>   SDLK_LEFT Constant <left>
SDLK_RIGHT Constant <right>  SDLK_UP Constant <up>     SDLK_DOWN Constant <down>
SDLK_PRINT Constant <prtsc>  SDLK_LSHIFT Constant <lshift> SDLK_RSHIFT Constant <rshift>
SDLK_RALT Constant <ralt>    SDLK_PERIOD constant <.>
SDLK_LCTRL Constant <lctrl>  SDLK_RCTRL Constant <rctrl>  SDLK_LALT Constant <lalt>
SDLK_PAUSE Constant <break>
SDLK_KP_MINUS Constant <kp->
SDLK_KP_PLUS Constant <kp+>
SDLK_KP0 Constant <kp0>
SDLK_KP1 Constant <kp1>
SDLK_KP2 Constant <kp2>
SDLK_KP3 Constant <kp3>
SDLK_KP4 Constant <kp4>
SDLK_KP5 Constant <kp5>
SDLK_KP6 Constant <kp6>
SDLK_KP7 Constant <kp7>
SDLK_KP8 Constant <kp8>
SDLK_KP9 Constant <kp9>
1 Constant lb
4 Constant rb
2 Constant mb

CREATE kbuf 512 ALLOT
CREATE kbuf2 512 ALLOT

Variable mbtn
Variable mbtnLast

Variable mx
Variable my
Variable mz
Variable mx.
Variable my.
Variable mz.

Variable mxlast
Variable mylast
Variable mzlast

Variable mxchange
Variable mychange
Variable mzchange

0 value wheelspeed  1 to wheelspeed

\ Mouse

\ Need to get real desktop res here.
: mxfactor
   fullscreen? if screen-w desktop-w ./ else 1.0 then ;

: myfactor
   fullscreen? if screen-h desktop-h ./ else 1.0 then ;


: clip-mouse
   0 max screen-h s>. min swap
   0 max screen-w s>. min swap ;



0 value mouse-warped?

: poll-mouse ( -- )
   mbtn @ mbtnlast !
   mx @ mxlast !
   my @ mylast !
   mxchange mychange SDL_GetRelativeMouseState mbtn !
   mouse-warped? not if
      mx. @ mxchange @ s>. mxfactor .* +
      my. @ mychange @ s>. myfactor .* +
      fullscreen? if clip-mouse then
      2dup my. ! mx. ! 2.>s my ! mx !
   then
   false to mouse-warped? ;

: mouse ( -- x y )
   mx @ my @ ;

: mickey ( -- x y )
   mxlast @ mylast @ ;

: mouse-delta ( -- x y )
   mx @ mxlast @ -  my @ mylast @ - ;

: mButton? ( n -- flag )
   mbtn @ AND ;

: mButton2? ( n -- flag )
   mbtnlast @ AND ;

: mPress? ( n -- flag )
   dup mbutton2? NOT swap mButton? AND ;

: mLetgo? ( n -- flag )
   dup mbutton? NOT swap mButton2? AND ;

: !mouse ( x y -- )
   2s>. clip-mouse 2dup 2.>s SDL_WarpMouse 2dup my. ! mx. ! 2.>s my ! mx !  true to mouse-warped? ;

: +mouse
   mx @ my @ 2+ !mouse  ;

\ Keyboard

: poll-keyboard ( -- )
   kbuf kbuf2 512 move
   0 SDL_GetKeyState kbuf 512 move ;

-? : key? ( n -- flag )
   kbuf + C@ ;

: KEY2? ( n -- flag )
   kbuf2 + C@ ;

: press? ( n -- flag )
   DUP KEY2? NOT SWAP KEY? AND ;

: letgo? ( n -- flag )
   dup key2? NOT swap key? AND ;

: ALT? ( -- flag )
   <lalt> KEY? <ralt> KEY? OR ;

: CTRL? ( -- flag )
   <lctrl> KEY? <rctrl> KEY? OR ;

: SHIFT? ( -- flag )
   <LShift> KEY? <RShift> KEY? OR ;

\ Mouse wheel

create event 256 allot

\ mouse info: see sdl_events.h and sdl_mouse.h, or SDL.f

: mWheel
   mz @ ;

: mWheel! ( n -- )
   mz ! ;

: +mz
   mz @ mzlast !
   mz +!
   mz @ mzlast @ - mzchange ! ;

: (wheel)
   event 2 + c@
   dup 4 = if
      wheelspeed negate +mz then
   5 = if wheelspeed +mz then ;


\ Drag & drop

{
/* The Windows custom event structure */
struct SDL_SysWMmsg
{
    SDL_version version;
    HWND hwnd;                  /* The window for the message */
    UINT msg;                   /* The type of message */
    WPARAM wParam;              /* WORD message parameter */
    LPARAM lParam;              /* LONG message parameter */
}

: do-gfx-drop ( -- )
   event cell+ @ 3 cells + @ -1 0 0 DragQueryFile 1 > IF
      HWND Z" Drop one file at a time" Z" Error!"
      MB_ICONSTOP MessageBox DROP EXIT
   THEN
   S\" \zDROP-INCLUDE " PAD PLACE
   event cell+ @ 3 cells + @ 0 HERE 255 DragQueryFile DROP
   HERE ZCOUNT PAD APPEND
   S\" \r" PAD APPEND  PAD COUNT  OPERATOR'S PUSHTEXT
   event cell+ @ cell+ @ DragFinish  ;

: (dragdrop) ( -- )
   event cell+ @ cell+ cell+ @ WM_DROPFILES = if do-gfx-drop then ;

: enable-seki-dragdrop ( -- )
   seki-window 1 DragAcceptFiles
   SDL_SYSWMEVENT 1 sdl_eventstate ;

defer keydown ' drop is keydown  ( scancode -- )
defer keyup  ' drop is keyup     ( scancode -- )
defer winresize  ' 2drop is winresize  ( w h -- )

:[] keydown:[ is keydown ;
:[] keyup:[ is keyup ;
:[] resize:[  is winresize ;

\ Polling

variable editor-mode?

: handle-event
      event c@ case
         SDL_MOUSEMOTION of (wheel) endof
         SDL_SYSWMEVENT of (dragdrop) endof
         SDL_KEYDOWN of event 8 + h@ keydown endof
         SDL_KEYUP of event 8 + h@ keyup endof
         SDL_MOUSEBUTTONDOWN of endof
         SDL_MOUSEBUTTONUP of endof
         SDL_VIDEORESIZE of event cell+ @+ swap @ winresize endof
\         SDL_VIDEOEXPOSE of endof
         SDL_ACTIVEEVENT of endof
      endcase ;

: wait-event
   begin 1 Sleep drop ." " event SDL_PollEvent until ;

: poll-all ( -- )
   editor-mode? @ if wait-event handle-event then
   begin event SDL_PollEvent while handle-event repeat
   poll-mouse poll-keyboard ;

: init-input
  SDL_Init( SDL_INIT_JOYSTICK ) drop
  kbuf 512 erase
  kbuf2 512 erase
  0 mbtn !
  0 mbtnlast !
  \ 0 0 !mouse
  mx my SDL_GetMouseState drop
  mx @ s>. mx. !
  my @ s>. my. !
  ;

